Visual Basic 4 Database How-To/Visual Basic 4 Database - How-to (The Waite Group)(1995).iso/relater.fr_/relater.fr

Text File | 1995-03-09 | 20KB | 584 lines

VERSION 4.00
Begin VB.Form Form1
   BackColor       =   &H00C0C0C0&
   Caption         =   "Relation Creator"
   ClientHeight    =   4590
   ClientLeft      =   510
   ClientTop       =   1395
   ClientWidth     =   7755
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   4995
   Left            =   450
   LinkTopic       =   "Form1"
   ScaleHeight     =   4590
   ScaleWidth      =   7755
   Top             =   1050
   Width           =   7875
   Begin VB.CommandButton cmdCreateRelations
      Caption         =   "Create &Relations"
      Enabled         =   0   'False
      Height          =   495
      Left            =   2100
      TabIndex        =   7
      Top             =   1500
      Width           =   2055
   End
   Begin VB.ListBox lstTables
      Height          =   1980
      Left            =   180
      TabIndex        =   4
      Top             =   660
      Width           =   1695
   End
   Begin VB.CommandButton cmdCreateTable
      Caption         =   "--> Create &Table -->"
      Enabled         =   0   'False
      Height          =   495
      Left            =   2100
      TabIndex        =   2
      Top             =   840
      Width           =   2055
   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "Cl&ose"
      Height          =   495
      Left            =   2100
      TabIndex        =   1
      Top             =   2160
      Width           =   2055
   End
   Begin VB.CommandButton cmdCreateDatabase
      Caption         =   "&Create &Database"
      Height          =   495
      Left            =   2100
      TabIndex        =   0
      Top             =   180
      Width           =   2055
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Relationships:"
      Height          =   195
      Left            =   300
      TabIndex        =   9
      Top             =   2880
      Width           =   1215
   End
   Begin MSGrid.Grid grdRelationships
      Height          =   1020
      Left            =   300
      TabIndex        =   8
      Top             =   3180
      Width           =   7170
      _version        =   65536
      _extentx        =   12647
      _extenty        =   1799
      _stockprops     =   77
      backcolor       =   16777215
      fixedcols       =   0
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Created Tables, Fields, and Indexes:"
      Height          =   195
      Left            =   4380
      TabIndex        =   6
      Top             =   360
      Width           =   3135
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Available Tables:"
      Height          =   195
      Left            =   180
      TabIndex        =   5
      Top             =   360
      Width           =   1485
   End
   Begin MSOutl.Outline outTablesAndFields
      Height          =   1995
      Left            =   4380
      TabIndex        =   3
      Top             =   660
      Width           =   3135
      _version        =   65536
      _extentx        =   5530
      _extenty        =   3519
      _stockprops     =   77
      backcolor       =   16777215
      pictureplus     =   "RELATER.frx":0000
      pictureminus    =   "RELATER.frx":0172
      pictureleaf     =   "RELATER.frx":02E4
      pictureopen     =   "RELATER.frx":0456
      pictureclosed   =   "RELATER.frx":05C8
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   1620
      Top             =   60
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
      defaultext      =   "MDB"
      dialogtitle     =   "Create New Database"
      filter          =   "Microsoft Acccess (*.MDB)|*.MDB"
      flags           =   5000
   End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' Declare the text field lengths as constants
Private Const LEN_Customer_Name = 40
Private Const LEN_Street_Address = 80
Private Const LEN_City = 25
Private Const LEN_State = 2
Private Const LEN_Zip_Code = 10
Private Const LEN_Country = 25
Private Const LEN_Item_Number = 16
Private Const LEN_Item_Description = 100

' Declare the database at form level.
Dim db As Database

Private Sub cmdCreateDatabase_Click()
    Dim fn As String
    Dim tblDef As TableDef

    On Error GoTo CreateError

    ' Set the filename to a null string and display the common dialog box.
    CommonDialog1.FileName = ""
    CommonDialog1.ShowSave

    ' The user entered a filename for the new database. Assign it to the variable fn.
    Screen.MousePointer = 11
    fn = CommonDialog1.FileName

    ' Create the new database file.
    Set db = DBEngine.Workspaces(0).CreateDatabase(fn, dbLangGeneral)
    Screen.MousePointer = 0

    ' Verify that the file now exists on disk.
    If Dir(fn) = CommonDialog1.FileTitle Then

        ' The file exists, so display a message.
        Form1.Caption = "Relation Creator for " & UCase$(fn)

        ' Clear the existing list and outline
        lstTables.Clear
        outTablesAndFields.Clear

        ' Fill the list box with the sample tables
        lstTables.AddItem "Customers"
        lstTables.AddItem "Items"
        lstTables.AddItem "Order Items"
        lstTables.AddItem "Orders"

        ' If a table already exists in the database, remove it from the
        ' list and add it to the outline.
        For Each tblDef In db.TableDefs
            Select Case tblDef.Name
                Case "Customers"
                    RemoveFromList "Customers"
                    AddToOutline "Customers"
                Case "Orders"
                    RemoveFromList "Orders"
                    AddToOutline "Orders"
                Case "Items"
                    RemoveFromList "Items"
                    AddToOutline "Items"
                Case "Order Items"
                    RemoveFromList "Order Items"
                    AddToOutline "Order Items"
                Case Else
            End Select
        Next

        ' Enable the Create Table features and disable Create Relationships.
        cmdCreateTable.Enabled = True
        cmdCreateRelations.Enabled = False

    Else
        MsgBox "Could not create " & fn, vbExclamation
    End If
Exit Sub

CreateError:
    Screen.MousePointer = 0
    If Err.Number = 32755 Then
        ' The user cancelled the dialog box, so do nothing.
    Else
        ' Some other error, so show the user the description.
        MsgBox Err.Description
    End If
Exit Sub
End Sub


Private Sub cmdCreateTable_Click()
    Dim tableName As String
    Dim tblDef As TableDef

    On Error GoTo TableCreateError

    If lstTables.ListIndex > -1 Then

        ' The user has a table selected, so create a new table definition
        ' in the database with the name of the table.
        Screen.MousePointer = 11
        Set tblDef = db.CreateTableDef(lstTables.Text)

        ' Now add the appropriate fields to the table.
        AddFields tblDef

        ' Next the primary key to the table.
        AddPrimaryKey tblDef

        ' Add other indexes
        AddOtherIndexes tblDef

        ' With all the fields in place, append the table defintion to the database.
        db.TableDefs.Append tblDef

        ' Take the list off the list of available tables.
        tableName = lstTables.Text
        RemoveFromList tableName

        ' Put the table and its fields into the outline of tables in the database.
        AddToOutline tableName
    End If

    ' If the user has added all the tables, enable the Create Relationshops button.
    If lstTables.ListCount = 0 Then cmdCreateRelations.Enabled = True
    Screen.MousePointer = 0

Exit Sub

TableCreateError:
    Screen.MousePointer = 0
    MsgBox Err.Description
Exit Sub

End Sub
Sub AddFields(tblDef As TableDef)

    Dim fldDef As Field

    ' For each field, first create the field TableDef
    ' Then add it to the field list for the table
    Select Case tblDef.Name
        Case "Customers"
            Set fldDef = tblDef.CreateField("Customer Number", dbLong)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Customer Name", dbText, LEN_Customer_Name)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Street Address", dbText, LEN_Street_Address)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("City", dbText, LEN_City)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("State", dbText, LEN_State)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Zip Code", dbText, LEN_Zip_Code)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Country", dbText, LEN_Country)
            tblDef.Fields.Append fldDef
        Case "Items"
            Set fldDef = tblDef.CreateField("Item Number", dbText, LEN_Item_Number)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Item Description", dbText, LEN_Item_Description)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Price Each", dbCurrency)
            tblDef.Fields.Append fldDef
        Case "Orders"
            Set fldDef = tblDef.CreateField("Customer Number", dbLong)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Order Number", dbLong)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Order Date", dbDate)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Ship Date", dbDate)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Tax", dbCurrency)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Shipping Charge", dbCurrency)
            tblDef.Fields.Append fldDef
        Case "Order Items"
            Set fldDef = tblDef.CreateField("Order Number", dbLong)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Item Number", dbText, LEN_Item_Number)
            tblDef.Fields.Append fldDef
            Set fldDef = tblDef.CreateField("Quantity", dbLong)
            tblDef.Fields.Append fldDef
    End Select

End Sub
Sub AddPrimaryKey(tblDef As TableDef)
    Dim idx As Index
    Dim idxField1 As Field, idxField2 As Field

    ' Create the index.
    Set idx = tblDef.CreateIndex("PrimaryKey")

    ' Define the field(s) for the index
    Select Case tblDef.Name
        Case "Customers"
            Set idxField1 = idx.CreateField("Customer Number")
        Case "Items"
            Set idxField1 = idx.CreateField("Item Number")
        Case "Orders"
            Set idxField1 = idx.CreateField("Order Number")
        Case "Order Items"
            Set idxField1 = idx.CreateField("Order Number")
            Set idxField2 = idx.CreateField("Item Number")
    End Select
    idx.Fields.Append idxField1
    If tblDef.Name = "Order Items" Then idx.Fields.Append idxField2

    idx.Primary = True
    tblDef.Indexes.Append idx
End Sub
Sub AddOtherIndexes(tblDef As TableDef)
    Dim idx As Index
    Dim idxField1 As Field, idxField2 As Field


    ' Create the indexes, define the field(s) and properties
    Select Case tblDef.Name

        Case "Customers"

            ' Define the Customer Name index as a required index.
            Set idx = tblDef.CreateIndex("Customer Name")
            Set idxField1 = idx.CreateField("Customer Name")
            idx.Fields.Append idxField1
            idx.Required = True
            tblDef.Indexes.Append idx

            ' Define the City And State index as a required index.
            Set idx = tblDef.CreateIndex("City And State")
            Set idxField1 = idx.CreateField("State")
            Set idxField2 = idx.CreateField("City")
            idx.Fields.Append idxField1
            idx.Fields.Append idxField2
            idx.Required = True
            tblDef.Indexes.Append idx

            ' Define the Zip index as a required index.
            Set idx = tblDef.CreateIndex("Zip")
            Set idxField1 = idx.CreateField("Zip Code")
            idx.Fields.Append idxField1
            idx.Required = True
            tblDef.Indexes.Append idx

        Case "Items"

            ' Define the City And State index as a required and unique index.
            Set idx = tblDef.CreateIndex("Item Description")
            Set idxField1 = idx.CreateField("Item Description")
            idx.Fields.Append idxField1
            idx.Required = True
            idx.Unique = True
            tblDef.Indexes.Append idx

        Case "Orders"

            ' Define the Customer Number index as a required index.
            Set idx = tblDef.CreateIndex("Customer Number")
            Set idxField1 = idx.CreateField("Customer Number")
            idx.Fields.Append idxField1
            idx.Required = True
            tblDef.Indexes.Append idx

            ' Define the Order Date index as a required index.
            Set idx = tblDef.CreateIndex("Order Date")
            Set idxField1 = idx.CreateField("Order Date")
            idx.Fields.Append idxField1
            idx.Required = True
            tblDef.Indexes.Append idx

            ' Define the Ship Date index as a non-required index.
            Set idx = tblDef.CreateIndex("Ship Date")
            Set idxField1 = idx.CreateField("Ship Date")
            idx.Fields.Append idxField1
            tblDef.Indexes.Append idx

        Case "Order Items"

            ' Define the Item Number index.
            ' The field is already part of the Primary Key, so no need to define it as required.
            Set idx = tblDef.CreateIndex("Item Number")
            Set idxField1 = idx.CreateField("Item Number")
            idx.Fields.Append idxField1
            tblDef.Indexes.Append idx

            ' Define the Order Number index.
            ' The field is already part of the Primary Key, so no need to define it as required.
            Set idx = tblDef.CreateIndex("Order Number")
            Set idxField1 = idx.CreateField("Order Number")
            idx.Fields.Append idxField1
            tblDef.Indexes.Append idx

    End Select
End Sub

Private Sub cmdCreateRelations_Click()
    Dim relate As Relation
    Dim fld As Field

    On Error GoTo RelationshipsError

    Screen.MousePointer = 11

    Set relate = db.CreateRelation("First")
    relate.Table = "Customers"
    relate.ForeignTable = "Orders"
    Set fld = relate.CreateField("Customer Number")
    fld.ForeignName = "Customer Number"
    relate.Fields.Append fld
    db.Relations.Append relate
    grdRelationships.AddItem relate.Table & Chr$(9) & relate.ForeignTable & Chr$(9) & fld.Name & Chr$(9) & IIf(relate.Attributes = dbRelationDeleteCascade, "Yes", "No")

    Set relate = db.CreateRelation("Second")
    relate.Table = "Orders"
    relate.ForeignTable = "Order Items"
    Set fld = relate.CreateField("Order Number")
    fld.ForeignName = "Order Number"
    relate.Fields.Append fld
    relate.Attributes = dbRelationDeleteCascade
    db.Relations.Append relate
    grdRelationships.AddItem relate.Table & Chr$(9) & relate.ForeignTable & Chr$(9) & fld.Name & Chr$(9) & IIf(relate.Attributes = dbRelationDeleteCascade, "Yes", "No")

    Set relate = db.CreateRelation("Third")
    relate.Table = "Items"
    relate.ForeignTable = "Order Items"
    Set fld = relate.CreateField("Item Number")
    fld.ForeignName = "Item Number"
    relate.Fields.Append fld
    relate.Attributes = dbRelationDeleteCascade
    db.Relations.Append relate
    grdRelationships.AddItem relate.Table & Chr$(9) & relate.ForeignTable & Chr$(9) & fld.Name & Chr$(9) & IIf(relate.Attributes = dbRelationDeleteCascade, "Yes", "No")

    grdRelationships.RemoveItem 1

    Screen.MousePointer = 0

Exit Sub

RelationshipsError:
    Screen.MousePointer = 0
    MsgBox Err.Description, vbExclamation
Exit Sub

End Sub

Private Sub Form_Load()
    grdRelationships.Cols = 4
    grdRelationships.ColWidth(0) = 1700
    grdRelationships.ColWidth(1) = 1700
    grdRelationships.ColWidth(2) = 1700
    grdRelationships.ColWidth(3) = 2000

    grdRelationships.Row = 0
    grdRelationships.Col = 0
    grdRelationships.Text = "Base Table"
    grdRelationships.Col = 1
    grdRelationships.Text = "Related Table"
    grdRelationships.Col = 2
    grdRelationships.Text = "Field"
    grdRelationships.Col = 3
    grdRelationships.Text = "Cascade Deletes?"

End Sub


Private Sub lstTables_DblClick()
    cmdCreateTable_Click
End Sub
Sub RemoveFromList(tableName As String)
    Dim i As Integer

    ' Find the table passed as the argument in the list and remove it from the list.
    For i = 0 To lstTables.ListCount - 1
        If lstTables.List(i) = tableName Then
            lstTables.RemoveItem i
            Exit For
        End If
    Next i

End Sub
Sub AddToOutline(tableName As String)
    Dim tableIndex As Integer
    Dim headerIndex As Integer
    Dim subHeaderIndex As Integer
    Dim tblDef As TableDef
    Dim idx As Index
    Dim i As Integer, j As Integer
    Dim trailer As String

    ' Indicate that the table name is to be added at the top level of the outline.
    outTablesAndFields.ListIndex = -1

    ' Add the table to the outline.
    outTablesAndFields.AddItem tableName

    ' Store the just-added table's ListIndex property in a variable.
    tableIndex = outTablesAndFields.ListCount - 1
    Set tblDef = db.TableDefs(tableName)

    ' Add each field in the table to the outline as a subitem of the table name.
    outTablesAndFields.ListIndex = tableIndex
    outTablesAndFields.AddItem "Fields"
    headerIndex = outTablesAndFields.ListCount - 1
    For i = 0 To tblDef.Fields.Count - 1
        outTablesAndFields.ListIndex = headerIndex
        outTablesAndFields.AddItem tblDef.Fields(i).Name
    Next i

    ' Add each index in the table to the outline as a subitem of the table name.
    outTablesAndFields.ListIndex = tableIndex
    outTablesAndFields.AddItem "Indexes"
    headerIndex = outTablesAndFields.ListCount - 1
    For i = 0 To tblDef.Indexes.Count - 1
        outTablesAndFields.ListIndex = headerIndex
        Set idx = tblDef.Indexes(i)
        If idx.Primary Then
            trailer = " [P]"
        ElseIf idx.Required And idx.Unique Then
            trailer = " [R,U]"
        ElseIf idx.Required Then
            trailer = " [R]"
        ElseIf idx.Unique Then
            trailer = " [U]"
        Else
            trailer = ""
        End If
        outTablesAndFields.AddItem idx.Name & trailer
        subHeaderIndex = outTablesAndFields.ListCount - 1
        For j = 0 To idx.Fields.Count - 1
            outTablesAndFields.ListIndex = subHeaderIndex
            outTablesAndFields.AddItem idx.Fields(j).Name
        Next j
    Next i

End Sub
Private Sub cmdClose_Click()
    End
End Sub